(QUOTE (THIS TRACE PACKAGE IS DEDICATED TO NANCY))

(DEF TRACE
 (LAMBDA ($FN $FLAG $INFORM $OUTFORM)
  (PROG ($A $B $C)
        (COND ((NUMBP $FLAG) NIL) (T (SETQ $FLAG 0)))
        (SETQ TRACELIST (CONS $FN TRACELIST))
        (SETQ $A (GETD $FN))
        (SETQ $B (COPY (CADR $A)))
        (RPLACD (CDR $A)
                (LIST
                 (LIST (QUOTE PROG)
                       (QUOTE ($RESULT))
                       (LIST (QUOTE PATOM)
                             (LIST (QUOTE QUOTE)
                                   (QUOTE "ENTERING ")))
                       (LIST (QUOTE PRINT)
                             (LIST (QUOTE QUOTE) $FN))
                       (QUOTE (TERPR))
                       (COND
                        ((OR (EQ $FLAG 2) (EQ $FLAG 4))
                         (LIST (QUOTE MAPC)
                               (QUOTE
                                (FUNCTION
                                 (LAMBDA ($D)
                                  (PROG NIL
                                        (PRINT $D)
                                        (PATOM (QUOTE =))
                                        (PRINT (EVAL $D))
                                        (TERPR)))))
                               (LIST (QUOTE QUOTE) $B))))
                       (COND
                        ((LESSP 2 $FLAG)
                         (QUOTE (BREAK (QUOTE TRACE)))))
                       $INFORM
                       (LIST (QUOTE SETQ)
                             (QUOTE $RESULT)
                             (CAR (CDDR $A)))
                       (QUOTE (PATOM (QUOTE "RETURNING FROM ")))
                       (LIST (QUOTE PRINT)
                             (LIST (QUOTE QUOTE) $FN))
                       (QUOTE (PATOM (QUOTE "   ")))
                       (COND
                        ((OR (EQ $FLAG 2) (EQ $FLAG 4))
                         (QUOTE (PRINT $RESULT))))
                       $OUTFORM
                       (COND
                        ((LESSP 2 $FLAG)
                         (QUOTE (BREAK (QUOTE TRACE)))))
                       (QUOTE (TERPR))
                       (QUOTE (RETURN $RESULT))))))))

(DEF UNTRACE
 (LAMBDA ($FN)
  (PROG ($A)
        (COND ((NULL (SETQ $A (GETD $FN))) (GO ERROR))
              ((EQ $FN (CAR TRACELIST))
               (SETQ TRACELIST (CDR TRACELIST)))
              (T
               (PROG (A B)
                     (SETQ A TRACELIST)
                LOOP (SETQ B (CDR A))
                     (COND ((NULL B) (GO ERROR))
                           ((EQ $FN (CAR B))
                            (RPLACD A (CDR B))
                            (RETURN)))
                     (SETQ A B)
                     (GO LOOP))))
        (RPLACD (CDR $A)
                (CDDR
                 (CADR
                  (CDDR (CDDR (CDDR (CDAR (CDDR $A))))))))
        (RETURN)
   ERROR(PRINT $FN)
        (PATOM (QUOTE " WASN'T TRACED"))
        (TERPR))))

(DEF UNTRACEALL
 (LAMBDA NIL (MAPC (GETD (QUOTE UNTRACE)) TRACELIST)))

(DEF UNTRACEL
 (NLAMBDA ($L) (MAPC (GETD (QUOTE UNTRACE)) $L)))

(DEF TRACE2
 (LAMBDA ($FN) (TRACE $FN $TRACEFLAG)))

(DEF TRACEL
 (NLAMBDA ($L)
   (PROG ($TRACEFLAG)
         (SETQ $TRACEFLAG (CAR $L))
         (COND ((NUMBP $TRACEFLAG)
                (MAPC (GETD (QUOTE TRACE2)) (CDR $L)))
               (T (SETQ $TRACEFLAG 0)
                  (MAPC (GETD (QUOTE TRACE2)) $L))))))

(DEF FLUSHTRACE
 (LAMBDA NIL
  (PROG NIL
        ($FLUSHLIST *TRACEFNS)
        (SETQ *TRACEFNS)
        ($MUMBLE NIL T)
        (RECLAIM)
        ($MUMBLE))))

 (SETQ *TRACEFNS
       (QUOTE
        (TRACE TRACEL
               TRACE2
               UNTRACE
               UNTRACEL
               UNTRACEALL
               FLUSHTRACE)))

 (QUOTE (THESE FUNCTIONS PUT UP ON UNIX BY JOHN))